home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / struct.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-16  |  13.4 KB  |  652 lines
  1. /* classes: src_files */
  2.  
  3. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  4.  * 
  5.  * This program is free software; you can redistribute it and/or modify
  6.  * it under the terms of the GNU General Public License as published by
  7.  * the Free Software Foundation; either version 2, or (at your option)
  8.  * any later version.
  9.  * 
  10.  * This program is distributed in the hope that it will be useful,
  11.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13.  * GNU General Public License for more details.
  14.  * 
  15.  * You should have received a copy of the GNU General Public License
  16.  * along with this software; see the file COPYING.  If not, write to
  17.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  */
  19.  
  20.  
  21.  
  22. #include <stdio.h>
  23. #include "_scm.h"
  24.  
  25.  
  26.  
  27. #define latte_type_format "S.S.SS*S"
  28.  
  29.  
  30. #ifdef __STDC__
  31. static SCM *
  32. allocate_object (int size, int type_objp)
  33. #else
  34. static SCM *
  35. allocate_object (size, type_objp)
  36.      int size;
  37.      int type_objp;
  38. #endif
  39. {
  40.   int extra;
  41.   SCM * data;
  42.  
  43.   extra = type_objp ? (2 + n_struct_header) : 0;
  44.   data = (SCM *)scm_must_malloc (sizeof (SCM) * (extra + size), "struct");
  45.   if (type_objp)
  46.     {
  47.       /* Ensure that the type data starts on an address
  48.        * aligned on a 2-word boundry.
  49.        */
  50.       *data = 0;
  51.       ++data;
  52.  
  53.       if ((unsigned long)data & 0x7)
  54.     {
  55.       *data = 1;
  56.       ++data;
  57.     }
  58.       if ((unsigned long)data & 0x7)
  59.     {
  60.       /* in case there are weird mallocs in the world */
  61.       ALLOW_INTS;
  62.       scm_puts ("\nFATAL ERROR DURING CRITICAL CODE SECTION\n", cur_errp);
  63.       exit(EXIT_FAILURE);
  64.     }
  65.     }
  66.   return data;
  67. }
  68.  
  69.  
  70.  
  71.  
  72. static char s_sys_make_struct[];
  73.  
  74. #ifdef __STDC__
  75. static SCM
  76. _scm_make_struct (SCM type, SCM nelts, int internal, int typeobjp)
  77. #else
  78. static SCM
  79. _scm_make_struct (type, nelts, internal, typeobjp)
  80.      SCM type;
  81.      SCM nelts;
  82.      int internal;
  83.      int typeobjp;
  84. #endif
  85. {
  86.   SCM answer;
  87.   SCM format;
  88.   int len;
  89.   int dyn_len;
  90.   SCM * mem;
  91.   SCM gc_prot_handle;
  92.   int shoudnt_make;
  93.  
  94.   /* As a special case, construct the 
  95.    * the root type.
  96.    */
  97.   if (type == BOOL_F)
  98.     {
  99.       if (first_type != BOOL_F)
  100.     return first_type;
  101.       else
  102.     {
  103.       SCM * protomem;
  104.       NEWCELL (type);
  105.       protomem = (SCM *)allocate_object (n_struct_header, 1);
  106.       DEFER_INTS;
  107.       CDR (type) = (SCM)protomem;
  108.       CAR (type) = (SCM)protomem + 1;
  109.       protomem[struct_i_name] = CAR (scm_intern0 ("latte-type"));
  110.       protomem[struct_i_vcell] = 0;
  111.       protomem[struct_i_format] = CAR (scm_intern0 (latte_type_format));
  112.       protomem[struct_i_refcnt] = 0;
  113.       protomem[struct_i_self] = type;
  114.       protomem[struct_i_sekrit] = BOOL_F;
  115.       protomem[struct_i_vtab_size] = 0;
  116.       ALLOW_INTS;
  117.       first_type = type;
  118.       return type;
  119.     }
  120.     }
  121.   
  122.   ASSERT (NIMP (type) && STRUCT_TYPEP (type), type, ARG1, s_sys_make_struct);
  123.   if ((nelts == BOOL_F) || (nelts == SCM_UNDEFINED))
  124.     nelts = MAKINUM (0);
  125.   ASSERT (INUMP (nelts), nelts, ARG2, s_sys_make_struct);
  126.  
  127.   format = STRUCT_TYPE_FORMAT (type);
  128.   len = LENGTH (format);
  129.   dyn_len = INUM (nelts);
  130.  
  131.   ASSERT ((dyn_len == 0) || ((len > 1) && ('*' == CHARS (format)[len - 2])),
  132.       dyn_len, OUTOFRANGE, s_sys_make_struct);
  133.  
  134.   NEWCELL (answer);
  135.   if (0 ==  STRUCT_TYPE_REFCNT(type))
  136.     {
  137.       NEWCELL (gc_prot_handle);
  138.     }
  139.  
  140.   DEFER_INTS;
  141.   if (0 ==  STRUCT_TYPE_REFCNT(type)++)
  142.     {
  143.       CAR (gc_prot_handle) = type;
  144.       CDR (gc_prot_handle) = type_obj_list;
  145.       type_obj_list = gc_prot_handle;
  146.     }
  147.   
  148.   CAR (answer) = CDR (type) + 1;
  149.   mem = allocate_object (len + dyn_len, typeobjp);
  150.   CDR (answer) = (SCM)mem;
  151.   {
  152.     char * f;
  153.     int i;
  154.     SCM last_val;
  155.     int f_inc;
  156.     int full_len;
  157.  
  158.     shoudnt_make = 0;
  159.     f_inc = 1;
  160.     full_len = len + dyn_len;
  161.     for (i = 0, f = CHARS (format); i < full_len; ++i, (f += f_inc))
  162.       {
  163.     switch (*f)
  164.       {
  165.       case 'I':
  166.       case 'F':
  167.       case 'L':
  168.       case 'D':
  169.       case '.':
  170.         if (!internal)
  171.           shoudnt_make = 1;
  172.       case 'i':
  173.       case 'f':
  174.       case 'l':
  175.       case 'd':
  176.       case '2':
  177.         mem[i] = last_val = 0;
  178.         break;
  179.  
  180.       case 'S':
  181.         if (!internal)
  182.           shoudnt_make = 1;
  183.       case 's':
  184.         mem[i] = last_val = EOL;
  185.         break;
  186.  
  187.       case '*':
  188.         if (i != (len - 2))
  189.           {
  190.         mem[i] = 0;
  191.         shoudnt_make = 1;
  192.           }
  193.         else
  194.           {
  195.         mem[i] = dyn_len;
  196.         f += 1;
  197.         f_inc = 0;
  198.           }
  199.         break;
  200.  
  201.       default:
  202.         shoudnt_make = 1;
  203.         mem[i] = 0;
  204.         break;
  205.       }
  206.       }
  207.   }
  208.   ALLOW_INTS;
  209.   ASSERT (!shoudnt_make, type,
  210.       "This type can't be instantiated genericly.",
  211.       s_sys_make_struct);
  212.   return answer;
  213. }
  214.  
  215.  
  216. PROC (s_sys_bottom_struct_type, "%bottom-struct-type", 0, 0, 0, scm_sys_bottom_struct_type);
  217. #ifdef __STDC__
  218. SCM 
  219. scm_sys_bottom_struct_type (void)
  220. #else
  221. SCM 
  222. scm_sys_bottom_struct_type ()
  223. #endif
  224. {
  225.   return _scm_make_struct (BOOL_F, 0, 1, 1);
  226. }
  227.  
  228.  
  229. PROC (s_sys_make_struct, "%make-struct", 1, 1, 0, scm_sys_make_struct);
  230. #ifdef __STDC__
  231. SCM
  232. scm_sys_make_struct (SCM type, SCM nelts)
  233. #else
  234. SCM
  235. scm_sys_make_struct (type, nelts)
  236.      SCM type;
  237.      SCM nelts;
  238. #endif
  239. {
  240.   return _scm_make_struct (type, nelts, 0, 0); /* fixme: typeobjp */
  241. }
  242.  
  243.  
  244. PROC (s_sys_make_struct_type, "%make-struct-type", 4, 0, 0, scm_sys_make_struct_type);
  245. #ifdef __STDC__
  246. SCM
  247. scm_sys_make_struct_type (SCM name, SCM format, SCM sekrit, SCM vtable)
  248. #else
  249. SCM
  250. scm_sys_make_struct_type (name, format, sekrit, vtable)
  251.      SCM name;
  252.      SCM format;
  253.      SCM sekrit;
  254.      SCM vtable;
  255. #endif
  256. {
  257.   SCM root_type;
  258.   SCM answer;
  259.   int vtab_len;
  260.  
  261.   ASSERT (NIMP (name) && SYMBOLP (name), name, ARG1, s_sys_make_struct_type);
  262.   ASSERT (NIMP (format) && SYMBOLP (format), name, ARG2, s_sys_make_struct_type);
  263.  
  264.   root_type = scm_sys_bottom_struct_type ();
  265.   vtab_len = scm_ilength (vtable);
  266.   answer = _scm_make_struct (root_type, MAKINUM (vtab_len), 1, 1);
  267.   STRUCT_TYPE_NAME (answer) = name;
  268.   STRUCT_TYPE_VCELL (answer) = 0;
  269.   STRUCT_TYPE_FORMAT (answer) = format;
  270.   STRUCT_TYPE_REFCNT (answer) = 1;
  271.   STRUCT_TYPE_SELF (answer) = answer;
  272.   STRUCT_TYPE_SEKRIT (answer) = sekrit;
  273.   STRUCT_TYPE_VTAB_SIZE (answer) = vtab_len;
  274.   {
  275.     int x;
  276.     for (x = 0; vtable != EOL; ++x, vtable = CDR (vtable))
  277.       STRUCT_TYPE_VTAB (answer)[x] = CAR (vtable);
  278.   }
  279.   return answer;
  280. }
  281.  
  282.  
  283. PROC (s_sys_struct_type_name, "%struct-type-name", 1, 0, 0, scm_sys_struct_type_name);
  284. #ifdef __STDC__
  285. SCM
  286. scm_sys_struct_type_name (SCM obj)
  287. #else
  288. SCM
  289. scm_sys_struct_type_name (obj)
  290.      SCM obj;
  291. #endif
  292. {
  293.   ASSERT (NIMP (obj) && STRUCTP (obj), obj, ARG1, s_sys_struct_type_name);
  294.   return STRUCT_TYPE_NAME (obj);
  295. }
  296.  
  297.  
  298. PROC (s_sys_struct_type_format, "%struct-type-format", 1, 0, 0, scm_sys_struct_type_format);
  299. #ifdef __STDC__
  300. SCM
  301. scm_sys_struct_type_format (SCM obj)
  302. #else
  303. SCM
  304. scm_sys_struct_type_format (obj)
  305.      SCM obj;
  306. #endif
  307. {
  308.   ASSERT (NIMP (obj) && STRUCTP (obj), obj, ARG1, s_sys_struct_type_format);
  309.   return STRUCT_TYPE_FORMAT (obj);
  310. }
  311.  
  312.  
  313.  
  314.  
  315. PROC (s_sys_struct_type_secret_p, "%struct-type-secret?", 2, 0, 0, scm_sys_struct_type_secret_p);
  316. #ifdef __STDC__
  317. SCM 
  318. scm_sys_struct_type_secret_p (SCM obj, SCM guess)
  319. #else
  320. SCM 
  321. scm_sys_struct_type_secret_p (obj, guess)
  322.      SCM obj;
  323.      SCM guess;
  324. #endif
  325. {
  326.   ASSERT (NIMP (obj) && STRUCT_TYPEP (obj),
  327.       obj, ARG1, s_sys_struct_type_secret_p);
  328.  
  329.   return (STRUCT_TYPE_SEKRIT (obj) == guess
  330.       ? BOOL_T
  331.       : BOOL_F);
  332. }
  333.  
  334.  
  335.  
  336. static char s_sys_struct_ref[];
  337. #ifdef __STDC__
  338. SCM
  339. _struct_ref (SCM obj, int i, int anyp)
  340. #else
  341. SCM
  342. _struct_ref (obj, i, anyp)
  343.      SCM obj;
  344.      int i;
  345.      int anyp;
  346. #endif
  347. {
  348.   SCM format;
  349.   char field_type;
  350.  
  351.   format = STRUCT_TYPE(obj)[struct_i_format];
  352.   if (   (i > 0)
  353.       && (i >= (-1 + LENGTH (format)))
  354.       && (CHARS(format)[-2 + LENGTH(format)] == '*'))
  355.     field_type = CHARS (format)[-1 + LENGTH (format)];
  356.   else
  357.     {
  358.       ASSERT ((0 <= i) && (i < LENGTH (format)),
  359.           MAKINUM (i), "ARG2 out of range", s_sys_struct_ref);
  360.       field_type = CHARS (format)[i];
  361.     }
  362.  
  363.   switch (field_type)
  364.     {
  365.     case '2':
  366.     default:
  367.     illegal:
  368.       scm_wta (MAKINUM (i), "illegal field", s_sys_struct_ref);
  369.  
  370.     case 'S':
  371.       if (!anyp) goto illegal;
  372.     case 's':
  373.       return ((SCM *)CDR (obj))[i];
  374.  
  375.     case 'I':
  376.       if (!anyp) goto illegal;
  377.     case 'i':
  378.     case '*':
  379.       return scm_long2num (((SCM *)CDR (obj))[i]);
  380.     case 'F':
  381.       if (!anyp) goto illegal;
  382.     case 'f':
  383.       return scm_makdbl ((double)*(float *)&(((SCM *)CDR (obj))[i]), 0.0);
  384.     case 'D':
  385.       if (!anyp) goto illegal;
  386.     case 'd':
  387.       return scm_makdbl (*(double *)&(((SCM *)CDR (obj))[i]), 0.0);
  388.     case 'L':
  389.       if (!anyp) goto illegal;
  390.     case 'l':
  391.       {
  392.     long * addr;
  393.     addr = (long *)&(((SCM *)CDR (obj))[i]);
  394. #ifdef LITTLE_ENDIAN
  395.     return MAKINUM (0);
  396. #else
  397.     return MAKINUM (0);
  398. #endif
  399.       }
  400.     }
  401. }
  402.  
  403.  
  404.  
  405. PROC (s_sys_struct_ref, "%struct-ref", 2, 0, 0, scm_sys_struct_ref);
  406. #ifdef __STDC__
  407. SCM
  408. scm_sys_struct_ref (SCM obj, SCM n)
  409. #else
  410. SCM
  411. scm_sys_struct_ref (obj, n)
  412.      SCM obj;
  413.      SCM n;
  414. #endif
  415. {
  416.   ASSERT (NIMP (obj) && STRUCTP (obj), obj, ARG1, s_sys_struct_ref);
  417.   ASSERT (INUMP (n), n, ARG2, s_sys_struct_ref);
  418.  
  419.   return _struct_ref (obj, INUM (n), 0);
  420. }
  421.  
  422. PROC (s_sys_struct_checked_ref, "%struct-checked-ref", 3, 0, 0, scm_sys_struct_checked_ref);
  423. #ifdef __STDC__
  424. SCM
  425. scm_sys_struct_checked_ref (SCM obj, SCM n, SCM secret)
  426. #else
  427. SCM
  428. scm_sys_struct_checked_ref (obj, n, secret)
  429.      SCM obj;
  430.      SCM n;
  431.      SCM secret;
  432. #endif
  433. {
  434.   ASSERT (NIMP (obj) && STRUCTP (obj),
  435.       obj, ARG1, s_sys_struct_checked_ref);
  436.   ASSERT (INUMP (n), n, ARG2, s_sys_struct_checked_ref);
  437.   ASSERT (SCM_STRUCT_TYPE (obj)[scm_struct_i_sekrit] == secret,
  438.       obj, ARG1, s_sys_struct_checked_ref);
  439.   return _struct_ref (obj, INUM (n), 1);
  440. }
  441.  
  442.  
  443.  
  444. PROC (s_sys_vtab_ref, "%vtab-ref", 2, 0, 0, scm_sys_vtab_ref);
  445. #ifdef __STDC__
  446. SCM
  447. scm_sys_vtab_ref (SCM obj, SCM n)
  448. #else
  449. SCM
  450. scm_sys_vtab_ref (obj, n)
  451.      SCM obj;
  452.      SCM n;
  453. #endif
  454. {
  455.   ASSERT (NIMP (obj) && STRUCT_TYPEP (obj), obj, ARG1, s_sys_vtab_ref);
  456.   ASSERT (INUMP (n), n, ARG2, s_sys_vtab_ref);
  457.   return _struct_ref (obj, struct_i_vtab + INUM (n), 1);
  458. }
  459.  
  460.  
  461. static char s_sys_struct_set_x[];
  462.  
  463. #ifdef __STDC__
  464. static SCM
  465. _sys_struct_set_x (SCM obj, SCM n, SCM val, SCM anyp)
  466. #else
  467. static SCM
  468. _sys_struct_set_x (obj, n, val, anyp)
  469.      SCM obj;
  470.      SCM n;
  471.      SCM val;
  472.      SCM anyp;
  473. #endif
  474. {
  475.   int i;
  476.   SCM format;
  477.   char field_type;
  478.  
  479.   i = INUM (n);
  480.   format = STRUCT_TYPE(obj)[struct_i_format];
  481.   if (   (i > 0)
  482.       && (i >= (-1 + LENGTH (format)))
  483.       && (CHARS(format)[-2 + LENGTH (format)] == '*'))
  484.     field_type = CHARS (format)[-1 + LENGTH (format)];
  485.   else
  486.     {
  487.       ASSERT ((0 <= i) && (i < LENGTH (format)),
  488.           n, "ARG2 out of range", s_sys_struct_ref);
  489.       field_type = CHARS (format)[i];
  490.     }
  491.  
  492.   switch (field_type)
  493.     {
  494.     case '*':
  495.     case '2':
  496.     default:
  497.     illegal:
  498.       scm_wta (n, "illegal field", s_sys_struct_set_x);
  499.  
  500.     case 'S':
  501.       if (!anyp) goto illegal;
  502.     case 's':
  503.       ((SCM *)CDR (obj))[i] = val;
  504.       break;
  505.  
  506.     case 'I':
  507.       if (!anyp) goto illegal;
  508.     case 'i':
  509.       ((SCM *)CDR (obj))[i] = scm_num2long (val, (char *)ARG3, s_sys_struct_set_x);
  510.       break;
  511.  
  512.     case 'u':
  513.       ((SCM *)CDR (obj))[i] = scm_num2ulong (val, (char *)ARG3, s_sys_struct_set_x);
  514.       break;
  515.  
  516.     case 'F':
  517.       if (!anyp) goto illegal;
  518.     case 'f':
  519.       *((float *)&(((SCM *)CDR (obj))[i])) = scm_num2dbl (val, s_sys_struct_set_x);
  520.       break;
  521.  
  522.     case 'D':
  523.       if (!anyp) goto illegal;
  524.     case 'd':
  525.       *((double *)&(((SCM *)CDR (obj))[i])) = scm_num2dbl (val, s_sys_struct_set_x);
  526.       break;
  527.  
  528.     case 'L':
  529.       if (!anyp) goto illegal;
  530.     case 'l':
  531.       {
  532.     long * addr;
  533.     long lo;
  534.     long hi;
  535.     addr = (long *)&(((SCM *)CDR (obj))[i]);
  536.     ASSERT (BOOL_T == scm_exact_p (val), val, ARG1, s_sys_struct_set_x);
  537.     lo = 0xbabe;
  538.     hi = 0xcafe;
  539. #ifdef LITTLE_ENDIAN
  540.     *addr = lo;
  541.     *(addr + 1) = hi;
  542. #else
  543.     *addr = hi;
  544.     *(addr + 1) = lo;
  545. #endif
  546.     break;
  547.       }
  548.     }
  549.   return UNSPECIFIED;
  550. }
  551.  
  552.  
  553. PROC (s_sys_struct_set_x, "%struct-set!", 3, 0, 0, scm_sys_struct_set_x);
  554. #ifdef __STDC__
  555. SCM
  556. scm_sys_struct_set_x (SCM obj, SCM n, SCM val)
  557. #else
  558. SCM
  559. scm_sys_struct_set_x (obj, n, val)
  560.      SCM obj;
  561.      SCM n;
  562.      SCM val;
  563. #endif
  564. {
  565.   ASSERT (NIMP (obj) && STRUCTP (obj), obj, ARG1, s_sys_struct_set_x);
  566.   ASSERT (INUMP (n), n, ARG2, s_sys_struct_set_x);
  567.  
  568.   return _sys_struct_set_x (obj, n, val, 0);
  569. }
  570.  
  571.  
  572. PROC (s_sys_struct_checked_set_x, "%struct-checked-set!", 4, 0, 0, scm_sys_struct_checked_set_x);
  573. #ifdef __STDC__
  574. SCM
  575. scm_sys_struct_checked_set_x (SCM obj, SCM n, SCM val, SCM secret)
  576. #else
  577. SCM
  578. scm_sys_struct_checked_set_x (obj, n, val, secret)
  579.      SCM obj;
  580.      SCM n;
  581.      SCM val;
  582.      SCM secret;
  583. #endif
  584. {
  585.   ASSERT (NIMP (obj) && STRUCTP (obj), obj, ARG1, s_sys_struct_checked_set_x);
  586.   ASSERT (INUMP (n), n, ARG2, s_sys_struct_checked_set_x);
  587.   ASSERT (SCM_STRUCT_TYPE (obj)[scm_struct_i_sekrit] == secret,
  588.       obj, ARG1, s_sys_struct_checked_ref);
  589.  
  590.   return _sys_struct_set_x (obj, n, val, 1);
  591. }
  592.  
  593.  
  594. PROC (s_sys_struct_p, "%struct?", 1, 0, 0, scm_sys_struct_p);
  595. #ifdef __STDC__
  596. SCM
  597. scm_sys_struct_p(SCM obj)
  598. #else
  599. SCM
  600. scm_sys_struct_p(obj)
  601.      SCM obj;
  602. #endif
  603. {
  604.   return ((NIMP (obj) && STRUCTP (obj))
  605.       ? BOOL_T
  606.       : BOOL_F);
  607. }
  608.  
  609. PROC (s_sys_struct_type_p, "%struct-type?", 1, 0, 0, scm_sys_struct_type_p);
  610. #ifdef __STDC__
  611. SCM
  612. scm_sys_struct_type_p(SCM obj)
  613. #else
  614. SCM
  615. scm_sys_struct_type_p(obj)
  616.      SCM obj;
  617. #endif
  618. {
  619.   return ((NIMP (obj) && STRUCT_TYPEP (obj))
  620.       ? BOOL_T
  621.       : BOOL_F);
  622. }
  623.  
  624. PROC (s_sys_struct_type, "%struct-type", 1, 0, 0, scm_sys_struct_type);
  625. #ifdef __STDC__
  626. SCM
  627. scm_sys_struct_type (SCM obj)
  628. #else
  629. SCM
  630. scm_sys_struct_type (obj)
  631.      SCM obj;
  632. #endif
  633. {
  634.   ASSERT (NIMP (obj) && STRUCTP (obj), obj, ARG1, s_sys_struct_type);
  635.   return STRUCT_TYPE (obj)[struct_i_self];
  636. }
  637.  
  638.  
  639.  
  640.  
  641. #ifdef __STDC__
  642. void
  643. scm_init_struct (void)
  644. #else
  645. void
  646. scm_init_struct ()
  647. #endif
  648. {
  649. #include "struct.x"
  650. }
  651.  
  652.